home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Examples-2.01 / mac-file-io.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  6.0 KB  |  146 lines  |  [TEXT/CCL2]
  1. ;;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;
  4. ;; mac-file-io.lisp
  5. ;;
  6. ;;Copyright © 1990, Apple Computer, Inc
  7. ;;
  8.  
  9. ;; This file implements something similar to the high-level file I/O
  10. ;; primitives in Inside Macintosh.
  11. ;; It does NOT support asynchronous I/O (and neither does the Macintosh, really).
  12.  
  13. ;; Routines that take an errorp parameter will signal an error if
  14. ;; the parameter is unspecified or true, otherwise, if there is an
  15. ;; error they return two values: NIL & the error number.
  16. ;; If there is no error, routines return one or more values the
  17. ;; first of which is non-NIL.
  18.  
  19. ;;;;;;;;;;;;;
  20. ;;
  21. ;; Modification History
  22. ;;
  23. ;; 
  24. ;; 04/28/93 mwp Release
  25. ;; 03/24/92 wkf  Added GetVInfo lisp version based on Inside Mac Volume IV p107
  26. ;; ------------- 2.0
  27. ;; 02/27/92 bill fsopen returns a useful value again.
  28. ;; 02/23/92 gb   Use newer traps, records, constants.
  29. ;; 02/12/92 bill fsopen gets a resolve-aliases-p parameter
  30. ;; ------------- 2.0f2
  31. ;; 12/31/91 bill use ccl::%err-disp in maybe-file-error
  32. ;; ------------- 2.0b4
  33. ;; 10/08/91 bill Move to CCL package
  34. ;; 09/05/91 bill no longer (require :records)
  35. ;; 08/24/91 gb   Use new trap syntax so no more 1.3.2.
  36. ;; 08/19/91 bill in FSOpen: (%put-word paramBlock $fsAtMark $ioPosOffset) ->
  37. ;;                          (%put-word paramBlock $fsAtMark $ioPosMode)
  38. ;;               (thanx to Dale J. Skrien)
  39. ;;
  40.  
  41. (in-package :ccl)
  42.  
  43. (eval-when (:compile-toplevel :load-toplevel :execute)
  44.   (export '(with-FSOpen-file FSOpen FSClose FSRead FSWrite setFPos getFPos getEOF)))
  45.  
  46. (defmacro with-FSOpen-file ((pb filename &optional read-write-p (vrefnum 0))
  47.                             &body body)
  48.   `(let ((,pb (FSOpen ,filename ,read-write-p ,vrefnum)))
  49.      (unwind-protect
  50.        (progn ,@body)
  51.        (FSClose ,pb))))
  52.  
  53. ; Returns a paramBlock for doing furthur I/O with the file
  54. (defun FSOpen (filename &optional read-write-p (vrefnum 0) (errorp t)
  55.                         (resolve-aliases-p t))
  56.   (when resolve-aliases-p (setq filename (truename filename)))
  57.   (let ((paramBlock (make-record :hparamblockrec))
  58.         ok)
  59.     (unwind-protect
  60.       (with-pstrs ((pname (mac-namestring filename)))
  61.         (setf (pref paramblock :hparamblockrec.ioNameptr) pname
  62.               (pref paramblock :hparamblockrec.ioVrefnum) vrefnum
  63.               (pref paramblock :hparamblockrec.ioVersNum) 0
  64.               (pref paramblock :hparamblockrec.ioPermssn) (if read-write-p #$fsRdWrPerm #$fsRdPerm)
  65.               (pref paramblock :hparamblockrec.ioMisc) (%null-ptr))
  66.         (#_Open paramBlock)
  67.         (let ((res (pref paramBlock :hparamblockrec.ioResult)))
  68.           (if (eql #$NoErr res)
  69.             (progn
  70.               (setf (pref paramblock :hparamblockrec.ioPosOffSet) 0
  71.                     (pref paramblock :hparamblockrec.ioPosMode) #$fsAtMark)
  72.               (setq ok t)
  73.               paramBlock)
  74.             (maybe-file-error errorp res filename))))
  75.       (unless ok
  76.         (#_DisposePtr paramBlock)))))
  77.  
  78. (defun FSClose (paramBlock &optional (errorp t))
  79.   (#_Close paramBlock)
  80.   (let ((errnum (pref paramBlock :hparamblockrec.ioResult)))
  81.     (#_DisposePtr paramBlock)
  82.     (or (eql errnum #$noErr)
  83.         (maybe-file-error errorp errnum))))
  84.  
  85. ; Returns two values: the number of bytes actually read, and the
  86. ; location of the file mark.
  87. (defun fsRead (paramBlock count buffer &optional (offset 0) (errorp t))
  88.   (setf (pref paramBlock :hparamblockrec.ioBuffer) (%inc-ptr buffer offset)
  89.         (pref paramBlock :hparamblockrec.ioReqCount) count)
  90.   (#_Read paramBlock)
  91.   (setf (pref paramBlock :hparamblockrec.ioPosMode) #$fsAtMark)
  92.   (let ((errnum (pref paramBlock :hparamblockrec.ioResult)))
  93.     (if (or (eql #$noErr errnum) (eql #$eofErr errnum))
  94.       (values (pref paramBlock :hparamblockrec.ioActCount)
  95.               (pref paramBlock :hparamblockrec.ioPosOffset))
  96.       (maybe-file-error errorp errnum))))
  97.  
  98. ; Returns two values: the number of bytes actually written, and the
  99. ; location of the file mark.
  100. (defun fsWrite (paramBlock count buffer &optional (offset 0) (errorp t))
  101.   (setf (pref paramBlock :hparamblockrec.ioBuffer) (%inc-ptr buffer offset)
  102.         (pref paramBlock :hparamblockrec.ioReqCount) count)
  103.   (#_Write paramBlock)
  104.   (setf (pref paramBlock :hparamblockrec.ioPosMode) #$fsAtMark)
  105.   (let ((errnum (pref paramBlock :hparamblockrec.ioResult)))
  106.     (if (or (eql #$noErr errnum) (eql #$eofErr errnum))
  107.       (values (pref paramBlock :hparamblockrec.ioActCount)
  108.               (pref paramBlock :hparamblockrec.ioPosOffset))
  109.       (maybe-file-error errorp errnum))))
  110.  
  111. (defun setFPos (paramBlock pos)
  112.   (setf (pref paramBlock :hparamblockrec.ioPosOffset) pos
  113.         (pref paramblock :hparamblockrec.ioPosMode) #$fsFromStart)
  114.   pos)
  115.  
  116. (defun getFPos (paramBlock)
  117.   (pref paramBlock :hparamblockrec.ioPosOffset))
  118.  
  119. (defun getEOF (paramBlock &optional (errorp t))
  120.   (let* ((errnum (#_GetEOF paramBlock)))
  121.     (if (eql #$noErr errnum)
  122.       (%ptr-to-int (pref paramblock :hparamblockrec.ioMisc))
  123.       (maybe-file-error errorp errnum))))
  124.  
  125. (defun GetVInfo (&key (volName "") (vRefNum 0))
  126.   (let* ((vol-pathname (truename (make-pathname :type nil :name nil :defaults volName)))
  127.          (directory    (pathname-directory vol-pathname)))
  128.     (assert (and directory (eq :absolute (car directory))))
  129.     (rlet ((paramBlock :hparamblockrec))
  130.       (with-returned-pstrs ((pname (cadr directory)))
  131.         (setf (pref paramblock :hparamblockrec.ioCompletion) (%null-ptr)
  132.               (pref paramblock :hparamblockrec.ioNamePtr)    pname
  133.               (pref paramblock :hparamblockrec.ioVRefNum)    vRefNum
  134.               (pref paramblock :hparamblockrec.ioVolIndex)   0)
  135.         (values (#_PBHGetVInfo paramBlock)
  136.                 (* (pref paramblock :hparamblockrec.ioVAlBlkSiz)
  137.                    (pref paramblock :hparamblockrec.ioVFrBlk))
  138.                 (pref paramblock :hparamblockrec.ioVRefNum)
  139.                 (%get-string (pref paramblock :hparamblockrec.ioNamePtr)))))))
  140.  
  141. (defun maybe-file-error (errorp errnum &optional filename)
  142.   (if errorp
  143.     (%err-disp errnum filename)
  144.     (values nil errnum)))
  145.  
  146. (provide :mac-file-io)